COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(declare 
C00012 ENDMK
C⊗;
(declare 
 (fasload meter)
 (load "metint.lsp")
 (setq meter:count-only ()))

(declare 

 (setq local-objects-of-interest 
       '( ((store (puzzle (class ?x)) *) "Stores of (puzzle (class x))")
	   ((store (piececount (class ?x)) *) "Stores of (piececount (class x))")
	   ((store (puzzle ?x) *) "Stores of (puzzle x)")
	   ((store (p ?x ?y) *) "Stores of (p x)")
	   ((store (piecemax ?x) *) "Stores of (piecemax x)")
	   ((store (class ?x) *) "Stores of (class x)")
	   ((puzzle (class ?x)) "References of (puzzle (class x))")
	   ((piececount (class ?x)) "References of (piececount (class x))")
	   ((puzzle ?x) "References of (puzzle x)")
	   ((p ?x ?y) "References of (p x)")
	   ((piecemax ?x) "References of (piecemax x)")
	   ((class ?x) "References of (class x)"))))

(declare 

 (defun (puzzle meter:expand-code) (form l avoid)
	(reference-code form l avoid))
 (defun (piececount meter:expand-code) (form l avoid)
	(reference-code form l avoid))
 (defun (p meter:expand-code) (form l avoid)
	(reference-code form l avoid))
 (defun (piecemax meter:expand-code) (form l avoid)
	(reference-code form l avoid))
 (defun (class meter:expand-code) (form l avoid)
	(reference-code form l avoid))
 (defun (store meter:expand-code) (form l avoid)
	(let ((q (reference-code (cadr form) l avoid)))
	     (cond ((or (atom (caddr form))
			(numberp (caddr form)))
		    `(,(car q) (store ,(cadr q) ,(caddr form))
			       ,(caddr q)))
		   (t (let ((r (gensym)))
			   `(,(append (car q) (ncons r))
			     (store ,(cadr q) ,r)
			     ,(append (caddr q) 
				      (ncons 
				       (meter:meter-funs l avoid (caddr form))))))))))
 (defun reference-code (form l avoid)
	(cond ((eq (car form) 'p)
	       (meter:bindable-form l avoid form))
	      ((atom ?x) 
	       `(() ,form ()))
	      (t (let ((r (gensym)))
			    `((,r)
			      ,(subst r ?x form)
			      (,(meter:meter-funs l avoid ?x)))))))
)

(declare (special size classmax typemax d)
	 (fixnum (place fixnum fixnum)
		 size classmax typemax d))

;(defmacro tab () '(tyo 9.))

(setq true t false ())
(declare (setq true t false ()))

(setq size 511.)
(setq classmax 3.)
(setq typemax 12.)
(setq d 8.)

(declare (special iii kount)
	 (fixnum iii i j k kount m n))

(declare (array* (fixnum piececount 1 class 1 piecemax 1)
		 (notype puzzle 1 p 2)))

(array piececount fixnum (1+ classmax))
(array class fixnum (1+ typemax))
(array piecemax fixnum (1+ typemax))
(array puzzle t (1+ size))
(array p t (1+ typemax) (1+ size))

(meter:meter puzzle
 (meter-funs #.(all-objs)
(defun fit (i j)
 (mn "FIT" fit)
 (let ((end (piecemax i)))
      (do ((k 0 (1+ k)))
	  ((> k end) #.true)
	  (cond ((p i k)
		 (cond ((puzzle (+ j k))
			(return #.false))))))))

(defun place (i j)
 (mn "PLACE" place)
       (let ((end (piecemax i)))
	    (do ((k 0 (1+ k)))
		((> k end))
		(cond ((p i k) 
		       (store (puzzle (+ j k)) #.true))))
	    (store (piececount (class i)) (- (piececount (class i)) 1))
	    (do ((k j (1+ k)))
		((> k size)
		 0)
		(cond ((not (puzzle k))
		       (mn "Returns" return)
		       (return k))))))

(defun remove (i j)
 (mn "REMOVE" remove)
       (let ((end (piecemax i)))
	    (do ((k 0 (1+ k)))
		((> k end))
		(cond ((p i k) 
		       (store (puzzle (+ j k)) #.false))))
	    (store (piececount (class i)) (+ (piececount (class i)) 1))))

(defun trial (j)
 (mn "TRIAL" trial)
       (let ((k 0))
	    (do ((i 0 (1+ i)))
		((> i typemax) (setq kount (1+ kount)) 
			       #.false)
		(cond ((not (= (piececount (class i)) 0))
		       (cond ((fit i j)
			      (setq k (place i j))
			      (cond ((or (trial k)
					 (= k 0))
				     (setq kount (+ kount 1))
				     (mn "Returns" return)
				     (return #.true))
				    (t (remove i j))))))))))

(defun definepiece (iclass ii jj kk)
 (mn "DEFINEPIECE" definepiece)
       (let ((index 0))
	    (do ((i 0 (1+ i)))
		((> i ii))
		(do ((j 0 (1+ j)))
		    ((> j jj))
		    (do ((k 0 (1+ k)))
			((> k kk))
			(setq index  (+ i (* d (+ j (* d k)))))
			(store (p iii index) #.true))))
	    (store (class iii) iclass)
	    (store (piecemax iii) index)
	    (cond ((not (= iii typemax))
		   (setq iii (+ iii 1))))))

(defun start ()
       (do ((m 0 (1+ m)))
	   ((> m size))
	   (store (puzzle m) #.true)) 
       (do ((i 1 (1+ i)))
	   ((> i 5))
	   (do ((j 1 (1+ j)))
	       ((> j 5))
	       (do ((k 1 (1+ k)))
		   ((> k 5))
		   (store (puzzle (+ i (* d (+ j (* d k))))) #.false))))
       (do ((i 0 (1+ i)))
	   ((> i typemax))
	   (do ((m 0 (1+ m)))
	       ((> m size))
	       (store (p i m) #.false)))
       (setq iii 0)
       (definePiece 0 3 1 0)
       (definePiece 0 1 0 3)
       (definePiece 0 0 3 1)
       (definePiece 0 1 3 0)
       (definePiece 0 3 0 1)
       (definePiece 0 0 1 3)

       (definePiece 1 2 0 0)
       (definePiece 1 0 2 0)
       (definePiece 1 0 0 2)

       (definePiece 2 1 1 0)
       (definePiece 2 1 0 1)
       (definePiece 2 0 1 1)

       (definePiece 3 1 1 1)

       (store (pieceCount 0) 13.)
       (store (pieceCount 1) 3)
       (store (pieceCount 2) 1)
       (store (pieceCount 3) 1)
       (let ((m (+ 1 (* d (+ 1 d))))
	     (n 0)(kount 0))
	    (cond ((fit 0 m) (setq n (place 0 m)))
		  (t (terpri)(princ "Error")))
	    (cond ((trial n) 
		   (terpri)(princ "success in ")(princ kount) (princ " trials")) 
		  (t (terpri)(princ "failure"))) 
	    (terpri)))))